{-# LANGUAGE CPP, DeriveDataTypeable, NamedFieldPuns, FlexibleContexts, NoMonomorphismRestriction  #-}

module Sim.Loader (
  getContext,
) where



import Control.Monad           ( forM  )
import Control.Monad.Error     ( runErrorT, strMsg, throwError, guard, liftIO )
import Control.Applicative     ( (<$>) )


import Data.String.Utils       ( split )
import Data.VectorSpace        ( (^-^), (^*), (*^), (^/) )
import Data.Array              ( Array, array, (!), bounds, elems )

import Text.Printf             ( printf )

import Sim.Loader.Parser
import Sim.Loader.Parser.Error
import Sim.Types

import Interpolation          ( biLerp )

import Sim.Helper             ( pair, (<~), verifyPoint, verifyFoV )
import Sim.Star               ( genRandomStars )
import Sim.ObsObject          ( ObsObject(..) )

import Sim.PSF                ( PsfData(..), BBox, toPsf, gaussPsf )

import qualified Sim.Helper   as H



---------------------- TEST -----------------------------
{-
test fn = runErrorT $ parseConfigFile fn (testParser_1)

testParser_1 :: ReaderT (ConfigParser, FilePath) (ErrorT SCPError IO) (Int, Double, Double->Double)
testParser_1 = do
  x <- get "MAIN_PARAMETERS" "ExposureTime"

  y <- parseConfigFile "sim.cfg" testParser_2

  f <- parseFuncFile "db/dev/dat/mr.dat"

  return (x,y,f)

testParser_2 = do
  return 11.0
-}
---------------------- TEST -----------------------------

--
getContext fn = do

   liftIO $ putStrLn "\n---====        Reading config       ====---\n"

   rv <- runErrorT $ parseConfigFile fn mainParser

   liftIO $ putStrLn "\n---====    End of reading config    ====---\n"

   case rv of
       Left  e -> error  $ show e
       Right c -> return c

-- Главный парсер для анализа файла конфигурации.
mainParser = do
  env <- envParser
  int <- intParser
  dev <- deviceParser  env int
  obj <- objectsParser env int dev

  return $ emptyContext { env, int, dev, obj }

emptyContext :: Context
emptyContext = Context { env=undefined
                       , ccd=undefined
                       , dev=undefined
                       , obj=undefined
                       , int=undefined
                       }

-- Парсер для анализа данных о "внешних условиях". 
envParser = do
  liftIO $ putStrLn "Parsing the Main Parameters section..."

  expT  <- get "MAIN_PARAMETERS" "ExposureTime"
  crF   <- get "MAIN_PARAMETERS" "CosmicRayFlux"
  mode  <- get "MAIN_PARAMETERS" "OperationMode"
  psf   <- get "MAIN_PARAMETERS" "PSFType"
  fld   <- get "MAIN_PARAMETERS" "FieldViewType"
  out   <- get "MAIN_PARAMETERS" "FileOutput"

  return $ Env { expTime  = expT
               , crFlux   = crF
               , opMode   = mode
               , psfType  = psf
               , fldType  = fld
               , output   = out
               }

-- Парсер для анализа данных о "Интеграторе".
intParser = do
  liftIO $ putStrLn "Parsing the Integrator section..."

  b <- get "INTEGRATOR" "IntLimits"
  h <- get "INTEGRATOR" "IntStep"

  return $ Integrator { limits=b, step=h, quad=H.quad b h }

-- Парсер для анализа данных о приборе
deviceParser env int = do
  liftIO $ putStrLn "Parsing the Device section..."

  title  <- get "DEVICE" "Title"
  fov'   <- get "DEVICE" "FieldOfView"

  -- переводим в градусы.
  let fov = fov' / 60

  sen    <- sensitivityParser
  adf    <- adfParser env int
  ccd    <- ccdParser env fov

  return $ Device { title       = title
                  , fieldView   = fov
                  , ccdArray    = ccd
                  , disperser   = adf
                  , sensitivity = sen
                  }

-- Парсер для анализа данных о типе дисперсера и функции угловой дисперсии.

adfParser env int = do

  case opMode env of

    SlitlessSpectroscopy -> do

           liftIO $ putStrLn "Parsing the Angle Dispersion Function section..."

           fc <- get "DEVICE" "ConfFileADF"

           parseConfigFile fc parser

    Imaging -> return None

   where
     parser = get "DEFAULT" "DisperserType" >>= parseDisperser

     parseDisperser TypeNone  = return None
     parseDisperser TypePrism = undefined
     parseDisperser TypeGrism = do

        ls  <- split "," <$> get "GRISM" "LOrders"
        rs  <- split "," <$> get "GRISM" "ROrders"  

        los <- mapM (\e -> get "GRISM" e >>= parseGrismOrderFile) ls
        ros <- mapM (\e -> get "GRISM" e >>= parseGrismOrderFile) rs

        oz  <- get "GRISM" "ZOrder"

        let  (l,r) = limits int
             los'  = filter (\(_,_,x) -> not $ x < l || x > r) <$> los
             ros'  = filter (\(_,_,x) -> not $ x < l || x > r) <$> ros

        return $ Grism los' oz ros'


-- Парсер для анализа данных об спектральной чувствительности
-- оптической системы прибора.
sensitivityParser = do
  liftIO $ putStrLn "Parsing the Optical Sensitivity section..."

  ae <- get "DEVICE" "EfficientArea"
  es <- get "DEVICE" "OpticalElements"

  ss <- mapM (\e -> get "DEVICE" e >>= parseFuncFile) (split "," es)

  let sen = (const ae) * (product ss)

  return sen

-- Парсер для анализа данных о ПЗС приемнике прибора.
ccdParser env fov = do
   liftIO $ putStrLn "Parsing the CCD section..."

   ls  <- get "DEVICE" "CCDChips"
   fcd <- get "DEVICE" "ConfFileDist"

   odf <- parseConfigFile fcd (distortionParser fov)

   psf <- psfParser env odf fov

   ccd <- mapM (ccdMainParser psf) ["CCD_CHIP_" ++ x | x <- split "," ls]

   return ccd

   where
      ccdMainParser psf name = do
         ff <- get name "FFPosition"
         fp <- get name "FPPosition"
         p  <- get name "PixelSize"
         w  <- get name "Width"
         h  <- get name "Height"
         t  <- get name "Thickness"
         b  <- get name "Bias"
         rn <- get name "ReadoutNoise"
         dn <- get name "DarkNoise"
         ml <- get name "MaxLevel"
         qe <- get name "QuantumEff" >>= parseFuncFile

         let (lx, zx) = properFraction $ fst fp
             (ly, zy) = properFraction $ snd fp

         return CCD { ffposition        = ff
                    , fpposition        = fp
                    , position          = (lx `div` p, ly `div` p)
                    , width             = w
                    , height            = h
                    , thickness         = t
                    , area              = 10e-8 * fromIntegral (p * w * h) -- плошать чипа в см^2
                    , bias              = b
                    , darkNoise         = dn
                    , readNoise         = rn
                    , maxLevel          = ml
                    , quantumEfficiency = qe
                    , psf               = psf p ((zx, zy), fromIntegral p)
                    }

-- Парсер для анализа данных о функции рассеяния точки (ФРТ) прибора.
psfParser env odf fov = do
  liftIO $ putStrLn "Parsing the PSF section..."

  case (psfType env) of
     Gauss  fwhm  -> do
                       let psf ps gr = (gaussPsf fwhm ps gr) . odf

                       return psf
     CustomPSF fc -> do
                       (sr,pd) <- parseConfigFile fc psfDataParser

                       let psf ps gr = (toPsf pd (ps * sr) gr) . odf   
        
                       return psf
  where
    psfDataParser = do
      (zp, h) <- get "PSF" "Grid"
      (n,  m) <- get "PSF" "GridSize"
      path    <- get "PSF" "FilePath"
      ext     <- get "PSF" "FileExtension"
      sr      <- get "PSF" "ScaleRatio"

--{--
      if not $ verifyFoV fov (zp,h) (n,m)
       then
        liftIO $ do

          let ((u,v), (u',v')) = 60 * fov
          let ((x,y), (x',y')) = 60 * (zp, zp + h *^ (pair fromIntegral (n,m) - 1))

          printf "\n**************   ERROR  *******************\n"
          printf   "                                           \n"
          printf   " The field of view of the device is larger \n"
          printf   " than given domain of PSF.                 \n"
          printf   "                                           \n"
          printf   "  FoV : (%5.2f',%5.2f'),(%5.2f',%5.2f')    \n" u v u' v'
          printf   "  PSF : (%5.2f',%5.2f'),(%5.2f',%5.2f')    \n" x y x' y'
          printf   "                                           \n"
          printf   "*******************************************\n"

          error "Execution stopped."
       else
        return ()
--}


      pd <- forM [1 .. (n*m)] $ \i -> do
               (p, fi) <- get "PSF" $ "Node_" ++ show i

               (b, f) <- parsePsfDataFile $ path ++ (show (fi::Int)) ++ ext

               let ij = pair round $ (p ^-^ zp) ^/ h

--{--
               if not $ verifyPoint p (zp,h)
                  then
                    liftIO $ do
                      printf "\n**************   ERROR  *******************\n"
                      printf   "                                           \n"
                      printf   " Coordinates of the node does not match to \n"
                      printf   " the given PSF grid.                       \n"
                      printf   "                                           \n"
                      printf   "  Node : %s\n" $ show p
                      printf   "  Grid : %s\n" $ show (zp,h)
                      printf   "                                           \n"
                      printf   "*******************************************\n"

                      error "Execution stopped."
                  else
                    return (b, (ij,f))
--}


      let rb    = (n,m)-1
          bs    = map fst pd
          ns    = map snd pd
        
          nodes = array (0,rb) ns
          bbox  = foldl merge (head bs) (tail bs)
   
      return (sr, PsfData (zp,h) bbox nodes)

        where
           merge :: BBox -> BBox -> BBox
           merge ((lx,ly),(rx,ry)) ((lu,lv),(ru,rv)) = (l,r)
              where
                 l = ((min lx lu), (min ly lv))
                 r = ((max rx ru), (max ry rv))

-- Парсер для анализа данных о дисторсии инструмента.
distortionParser fov = do
  liftIO $ putStrLn "Parsing the Distortion section..."

  (zp,h) <- get "DISTORTION" "Grid"
  (n, m) <- get "DISTORTION" "GridSize"
  fn     <- get "DISTORTION" "FileName"

  if not $ verifyFoV fov (zp,h) (n,m)
     then
        liftIO $ do

          let ((u,v), (u',v')) = 60 * fov
          let ((x,y), (x',y')) = 60 * (zp, zp + h *^ (pair fromIntegral (n,m) - 1))

          printf "\n**************   ERROR   ******************\n"
          printf   "                                           \n"
          printf   " The field of view of the device is larger \n" 
          printf   " than given domain of optical distortion.  \n"
          printf   "                                           \n" 
          printf   "  FoV  : (%5.3f',%5.3f'),(%5.3f',%5.3f')   \n" u v u' v'
          printf   "  DIST : (%5.3f',%5.3f'),(%5.3f',%5.3f')   \n" x y x' y'
          printf   "                                           \n" 
          printf   "*******************************************\n"

          error "Execution stopped."
     else
        return ()

  es'<- parseDistortionArrayFile fn 

  es <- forM es' $ \(uv,xy) -> do

          let ij = pair round $ (uv ^-^ zp) ^/ h
--{--

          if not $ verifyPoint uv (zp,h)
             then
               liftIO $ do
                 printf "\n**************   ERROR  *******************\n"
                 printf   "                                           \n"
                 printf   " Coordinates of the node does not match to \n"
                 printf   " given optical distortion grid.            \n"
                 printf   "                                           \n"
                 printf   "  Node : %s\n" $ show uv
                 printf   "  Grid : %s\n" $ show (zp,h)
                 printf   "                                           \n"
                 printf   "*******************************************\n"

                 error "Execution stopped."
             else
               return (ij,xy)
--}

  let rb = (n,m)-1
      ar = array (0,rb) es

  let fd = uncurry $ biLerp $ curry $ (<~) ar

  return $ \p -> (p, fd $ (p ^-^ zp) ^/ h)

--
objectsParser env int dev = do
  liftIO $ putStrLn "Parsing the Objects section..."

  lib  <- get "MAIN_PARAMETERS" "AvailableSpTypes" >>= parseSpectralTypesFile

  let sps = snd lib
      fov = fieldView dev

  (os,flt) <- case (fldType env) of
                RandomStars num -> do
                                     os <- liftIO $ genRandomStars sps fov num
                                     let flt = fst lib

                                     return (os,flt)
                CustomField fn  -> do
                                     (os,fl) <- parseObjectsFile sps fov fn
                                     flt     <- parseFuncFile fl

                                     return (os,flt)

  return $ Objects { objs = (map ObsObject os), magFilter = flt, atlasSpectralTypes = lib }

  where
    parseSpectralTypesFile fn = do
      liftIO $ putStrLn "Parsing the Spectral Types section..."

      (fv,fs) <- parseAtlasSpectralTypesFile fn 

      v  <- parseFuncFile fv
 
      sts <- forM fs $ \(st,fn) -> do

#ifdef DEBUG

         liftIO $ printf "\tLoading : %8s : %s\n" st fn
#endif

         o <- parseFuncFile fn

         return (st,o)

      return (v,sts)